;;; Top level for context sensitive grammar definition and language recognizer

(defun csg ()
  (prog (pdnlist start_symbol print_successors w sentence length_of_sentence seen)
      (csg_message)
      (setq pdnlist NIL)
      (setq start_symbol (explodec (request '|Start symbol = |)) )
    mkpdnlist
      (setq lhs (request '|Next production <lhs> → <rhs> or NIL to finnish|))
      (cond ((null lhs) (go rec)) )
      (cond ((not (eq (read) '→)) 
	     (read) (terpri) (princ '|invalid production delimiter|) (go mkpdnlist)) )
      (setq rhs (explodec (read)))
      (setq lhs (explodec lhs))
      (cond ((greaterp (length lhs) (length rhs)) 
	     (terpri) (princ '|invalid production -- lhs longer than rhs|)
             (go mkpdnlist)) )
      (setq pdnlist (cons (list lhs rhs ) pdnlist))
      (go mkpdnlist)
    rec
      (setq w (request '|Enter a word to be recognized.  NIL to quit|))
      (cond ((null w) (return 'the_end)) )
      (setq sentence (explodec w) )
      (setq length_of_sentence (length sentence))
      (setq seen NIL)
      (setq print_successors (request '|print successors?? (t or nil)|))
      (setq w (bsearch start_symbol))
      (print (cond ((atom w) 'no) (T  'yes)))
      (go rec) ))


(defun csg_message ()
   (princ '|This is a Context Sensitive Grammar recognizer|)
   (terpri)
   (princ '|The vocabulary must consist of letters A B ...|)
   (terpri)
   (princ '|One of these letters is designated as the start symbol|)
   (terpri)
   (princ '|A production has the form <lhs> "→" <rhs> where |)
   (terpri)
   (princ '|lhs and rhs are words made from letters  of the vocabulary|)
   (terpri)
   (princ '|and rhs is at least a long as lhs.|)
   (terpri)
   (princ '|Thus ABC → CBA is a valid production but ABC → BC is not.|)
   (terpri)
)


(defun request (msg) (terpri) (princ msg) (read))

;;; breadth first search auxiliaries  for sentence in Context Sensitive Lang
;;; see SEARCH.LSP for searching function BSEARCH

;;; global: pdnlist 
;;; global: seen  
;;; global: sentence, lentth_of_sentence
 
(defun successors (s) 
  (prog (ss)
    (setq ss (prune (apply_pdnlist s pdnlist)) )
    (cond (print_successors (terpri) (princ '|The unseen successors of |)
		            (princ s) (princ '|are: |) (princ ss)))
    (return ss)
  ))

;;; prune removes and elements of u that are in seen and adds the rest to seen
;;; returns the pruned u

(defun prune (u)
 (prog (v v1)
    (setq v (cons NIL u))
    (setq v1 v)
   ploop
    (cond ((null (cdr v)) (return (cdr v1))) )
    (cond ((member (cadr v) seen) (rplacd v (cddr v))(go ploop)) )
    (setq v (cdr v))
    (setq seen (cons (car v) seen))
    (go ploop) ))


;;; form a list of sentences immediately derivable from s via the productions in pl

(defun apply_pdnlist (s pl) 
  (cond ((null pl) NIL) 
	(T (append (apply_pdn (caar pl) (cadar pl) s) (apply_pdnlist s (cdr pl))) ) ))


(defun apply_pdn (alpha beta s)
  (mapcar (function (lambda (n) (subocc alpha beta s n))) (matches alpha s)) )

;;;replace occurrence of alpha at n in s by beta

(defun subocc (alpha beta s n) 
  (cond ((eq n 1) (subpat alpha beta s)) 
	(T (cons (car s) (subocc alpha beta (cdr s) (difference n 1)))) ))

(defun subpat (alpha beta s) 
  (cond ((null alpha) (append beta s)) 
	(T (subpat (cdr alpha) beta (cdr s))) ))

;;; form a list of a occurences of the list u in v

(defun matches (u v) (matches1 u v 1.)) 

(defun matches1 (u v n) 
  (cond ((null v) NIL)
        ((match u v) (cons n (matches1 u (cdr v) (add1 n))))
        (T (matches1 u (cdr v) (add1 n))))) 

(defun match (u v) 
  (cond ((null u) T)
	((null v) NIL)
	(T (and (eq (car u) (car v))
        (match (cdr u) (cdr v)))))) 

(defun losing (s) (greaterp (length s) length_of_sentence) )

(defun iswin (s) (equal s sentence) )

;;; sample production list

(setq pdnlist '(((s) (x s b c)) 
		((s) (x b c))
		((c b) (b c))
		((x b) (x y))
		((y b) (y y))
		((y c) (y z))
		((z c) (z z)) ) )

(setq start_symbol '(s))

;;; sample run

;;;Enter a word to be recognized.  NIL to quit  XYZ
;;;YES 

;;;Enter a word to be recognized.  NIL to quit XXYYZZ
;;;YES 

;;;Enter a word to be recognized.  NIL to quit ZXY
;;;NO